perm filename GMATCH.125[AID,LSP]1 blob
sn#659285 filedate 1982-05-19 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 The Matching Function
C00007 00003 Definitions for the Data Structures to be Matched
C00013 00004 Functions for Creating Function Names
C00014 00005 Macros for Unification
C00025 00006 Reader stuff to simplify typing and reading
C00037 00007 ?-RESTRICTIONS
C00041 00008 *-RESTRICTIONS
C00050 00009 *-IRESTRICTIONS
C00060 00010 ?-VARIABLE
C00063 00011 *-CLAUSE
C00067 00012 *-VARIABLE
C00071 00013 =?-VARIABLE
C00073 00014 Choose Clause
C00074 00015 Body
C00089 00016 The Unification Matcher
C00094 00017 Asymmetric Matcher
C00102 00018 Symmetric Matcher
C00110 ENDMK
C⊗;
;;;;;;;;;; The Matching Function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;; $r, ⊗r - same as RESTRICT
;;; (restrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given the list
;;; that is being considered for that variable as its argument
;;; (irestrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given each element of the list
;;; that is being considered for that variable as its argument
;;; (done incrementally). So %MATCH will apply these predicates as
;;; it scans the input.
;;; $ir,⊗ir - same as irestrict
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;; possible match between p and d (by different *-variable
;;; bindings.
;;*PAGE
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()))
;;; Definitions for the Data Structures to be Matched
;;; Note: for every P- there is a D-
;;; P-ATOMIC is a predicate that determines if this item is
;;; undecomposable
;;; P-CURRENT-ATOMIC tests whether the current item is recursive
;;; P-CURRENT returns the current item
;;; P-ADVANCE advances the object to the next
;;; P-VAR-TYPE returns the variable type of the p-atomic item supplied -
;;; has to return ?, *, =, and something else
;;; P-CHANGE-CURRENT changes the current item to the new value
;;; P-CHANGE changes the state so that the items supplied are the new items
;;; P-RESTRICT-VAR gets the restrict variable from the supplied current item
;;; P-MAP-BUILD like mapcar but with functions of 1 variable only and it
;;; operates on states
;;; P-EMPTY tests if P is empty
;;; P-CURRENT-EMPTY tests if the current element is empty
;;; P-LISTIFY turns P into a list
;;; P-LISTIFY-REST turns the rest of P into a list
;;; P-RESTRICT-FUNS returns the restrictions for the supplied current item
;;; P-RESTRICTP states whether an item is a restriction
;;; P-IRESTRICTP states whether an item is an incremental restriction
;;; P-FRESTRICTP states whether an item is a non-incremental restriction
;;; P-RESTRICT-VAR returns the restriction variable
;;; P-RESTRICT-TYPE return the type of restriction
;;; P-CREATE-RESTRICTION creates a restriction of the correct type from
;;; the parts supplied
;;; P-ADD-ITEM adds a new dummy item to the `front' of the data structure
;;; P-ADD-ITEMS adds new dummy items to the `front' of the data structure
;;; P-REST-EMPTY tests if the remainder of P is empty
;;; P-CREATE-STATE takes a data structure and returns a state suitable for
;;; the rest of the operations
;;; P-CHANGE-CURRENT-ITEMS replaces the current item with the items supplied
;;; P-CREATE-NULL-STATE creates a state with null content
;;; P-CREATE-STATE-FROM-CURRENT creates a state from the current item
;;; MATCH-NAME and MATCH-PREFIX ought to appear in the file as
;;; (EVAL-WHEN (COMPILE EVAL LOAD) (SETQ ..))
;;; P-CHECK is a function that is invoked before each assignment to
;;; a match variable. It has to take either a list of P-structures or
;;; a P data structure. In the Tree matcher's case it checks for circular
;;; structues and changes (-special-form- . x) into x
;;; Note, it does not take a STATE a may be defined for the above objects
;;; P-CHOOSEP tells if the supplied current-object is a CHOOSE variable
;;; P-CHOOSE-VAR returns the CHOOSE-VAR from the supplied current-object
;;; P-EMPTY-CHOICE determines if there are no more choices
;;; P-NEXT-CHOICE returns the next choice from a returned choice data
;;; structure
;;; NON-DETERMINISM is a flag like SYMMTERIC.
;;; P-CHOOSE-FIRST takes the pattern variable (along with predicates
;;; etc, and the rest of the data and returns a data structure
;;; which encapsulates the first choice and is something suitable
;;; for:
;;; P-CHOOSE-NEXT which takes the previous choice and produces the next.
;;; P-COMMENSURABLE takes two current objects and determines if they can
;;; be compared at all. Also, the flag TYPED is true if this does matter
;;; Functions for Creating Function Names
(EVAL-WHEN (COMPILE EVAL)
(OR (BOUNDP 'MATCH-PREFIX)
(SETQ MATCH-PREFIX '%%))
(OR (BOUNDP 'MATCH-NAME)
(SETQ MATCH-NAME '%UMATCH)))
(EVAL-WHEN (COMPILE EVAL)
(DEFUN CONCATENATE (X Y)
(IMPLODE (APPEND (EXPLODE X)
(EXPLODE Y))))
(DEFUN %%%MAKE-NAME%%% (X)
(IMPLODE (APPEND '#.(EXPLODE MATCH-PREFIX)
(EXPLODE X)))))
;;; Macros for Unification
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS))
(DECLARE (SPECIAL %/#FULL-PREDICATE))
(SETQ %/#FULL-PREDICATE ())
;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL)
(DEFMACRO P-SPECIAL-FORM (X)
`(LET ((QQQ ,X))
(COND ((%%P-SPECIAL-FORMP QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(DEFMACRO D-SPECIAL-FORM (X)
`(LET ((QQQ ,X))
(COND ((%%D-SPECIAL-FORMP QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(DEFMACRO CONSP (X) `(EQ (TYPEP ,X) 'LIST))
(DEFMACRO REAL-ATOM (%/#X)`(AND ,%/#X (ATOM ,%/#X)))
(DEFMACRO P-ALL-TRUE (FUN %/#L)
`(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (P-RESTRICTP %Q%)
(#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP) %Q%)
(FUNCALL ,FUN %Q%))
T))))
,%/#L)))
(DEFMACRO D-ALL-TRUE (FUN %/#L)
`(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (D-RESTRICTP %Q%)
(#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP) %Q%)
(FUNCALL ,FUN %Q%))
T))))
,%/#L)))
(DEFMACRO EXCHANGE (X Y)
`((LAMBDA (Q)
(SETQ ,X ,Y)
(SETQ ,Y Q))
,X))
;(DEFUN %%P-REAL-FORM (X)
; (COND ((P-ATOMIC X) X)
; ((AND (CONSP X)
; (EQ (CAR X)) '-SPECIAL-FORM-)
; (CDR X))
; (T X)))
;(DEFUN %%D-REAL-FORM (X)
; (COND ((P-ATOMIC X) X)
; ((AND (CONSP X)
; (EQ (CAR X)) '-SPECIAL-FORM-)
; (CDR X))
; (T X)))
(DEFUN #.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP) (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(MEMQ (P-VAR-TYPE X) '(? * =))))
(T (OR (AND (CONSP X)
(EQ (CAR X) '-SPECIAL-FORM-))
(P-RESTRICTP X)))) )
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP) (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(MEMQ (D-VAR-TYPE X) '(? * =))))
(T (OR (AND (CONSP X)
(EQ (CAR X) '-SPECIAL-FORM-))
(D-RESTRICTP X)))) )
(DEFMACRO ADD-ALIST (KEY VALUE ALIST)
` (CONS (CONS ,KEY ,VALUE) ,ALIST))
;;; Reader stuff to simplify typing and reading
(EVAL-WHEN (COMPILE EVAL)
(SETQ BACKQUOTE-EXPAND-WHEN 'EVAL))
(EVAL-WHEN (COMPILE EVAL)
(SETQ %VAR-LIST%
'(P D CP CD ALIST TAG P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
%%P-SPECIAL-FORMP
%%D-SPECIAL-FORMP
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-NEXT
#+NON-DETERMINISM D-CHOOSE-NEXT
#+TYPED P-COMMENSURABLE
#+TYPED D-COMMENSURABLE
UMATCH
UMATCH-R)
%VAR-LIST-R%
'(D P CD CP ALIST TAG D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
%%D-SPECIAL-FORMP
%%P-SPECIAL-FORMP
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-NEXT
#+NON-DETERMINISM P-CHOOSE-NEXT
#+TYPED D-COMMENSURABLE
#+TYPED P-COMMENSURABLE
UMATCH
UMATCH-R)
%ARG-LIST%
'`(,P ,D ,CP ,CD ,ALIST ,TAG ,P-ADVANCE ,D-ADVANCE
,P-CURRENT ,D-CURRENT ,P-RESTRICT-VAR ,D-RESTRICT-VAR
,P-CURRENT-ATOMIC ,D-CURRENT-ATOMIC
,P-CURRENT-EMPTY ,D-CURRENT-EMPTY
,P-EMPTY ,D-EMPTY ,P-CHANGE-CURRENT ,D-CHANGE-CURRENT
,P-CHANGE ,D-CHANGE ,P-CHANGE-CURRENT-ITEMS ,D-CHANGE-CURRENT-ITEMS
,P-ADD-ITEM ,D-ADD-ITEM ,P-ADD-ITEMS ,D-ADD-ITEMS
,P-RESTRICT-FUNS ,D-RESTRICT-FUNS
,%%P-SPECIAL-FORMP
,%%D-SPECIAL-FORMP
,P-CHECK
,D-CHECK
,P-CREATE-STATE-FROM-CURRENT ,D-CREATE-STATE-FROM-CURRENT
,P-ALL-TRUE ,D-ALL-TRUE
,P-ATOMIC ,D-ATOMIC
,P-RESTRICT-TYPE ,D-RESTRICT-TYPE
,P-IRESTRICTP ,D-IRESTRICTP
,P-FRESTRICTP ,D-FRESTRICTP
,P-CREATE-RESTRICTION ,D-CREATE-RESTRICTION
,P-VAR-TYPE ,D-VAR-TYPE ,P-CREATE-NULL-STATE ,D-CREATE-NULL-STATE
,P-LISTIFY ,D-LISTIFY ,P-LISTIFY-REST ,D-LISTIFY-REST
,P-RESTRICTP ,D-RESTRICTP
,P-SPECIAL-FORM ,D-SPECIAL-FORM
,P-REST-EMPTY ,D-REST-EMPTY
#+NON-DETERMINISM ,P-CHOOSEP
#+NON-DETERMINISM ,D-CHOOSEP
#+NON-DETERMINISM ,P-CHOOSE-VAR
#+NON-DETERMINISM ,D-CHOOSE-VAR
#+NON-DETERMINISM ,P-EMPTY-CHOICE
#+NON-DETERMINISM ,D-EMPTY-CHOICE
#+NON-DETERMINISM ,P-NEXT-CHOICE
#+NON-DETERMINISM ,D-NEXT-CHOICE
#+NON-DETERMINISM ,P-CHOOSE-FIRST
#+NON-DETERMINISM ,D-CHOOSE-FIRST
#+NON-DETERMINISM ,P-CHOOSE-NEXT
#+NON-DETERMINISM ,D-CHOOSE-NEXT
#+TYPED ,P-COMMENSURABLE
#+TYPED ,D-COMMENSURABLE
,UMATCH
,UMATCH-R)
%ARG-LIST-R%
'`(,D ,P ,CD ,CP ,ALIST ,TAG ,D-ADVANCE ,P-ADVANCE
,D-CURRENT ,P-CURRENT ,D-RESTRICT-VAR ,P-RESTRICT-VAR
,D-CURRENT-ATOMIC ,P-CURRENT-ATOMIC
,D-CURRENT-EMPTY ,P-CURRENT-EMPTY
,D-EMPTY ,P-EMPTY ,D-CHANGE-CURRENT ,P-CHANGE-CURRENT
,D-CHANGE ,P-CHANGE ,D-CHANGE-CURRENT-ITEMS ,P-CHANGE-CURRENT-ITEMS
,D-ADD-ITEM ,P-ADD-ITEM ,D-ADD-ITEMS ,P-ADD-ITEMS
,D-RESTRICT-FUNS ,P-RESTRICT-FUNS
,%%D-SPECIAL-FORMP
,%%P-SPECIAL-FORMP
,D-CHECK
,P-CHECK
,D-CREATE-STATE-FROM-CURRENT ,P-CREATE-STATE-FROM-CURRENT
,D-ALL-TRUE ,P-ALL-TRUE
,D-ATOMIC ,P-ATOMIC
,D-RESTRICT-TYPE ,P-RESTRICT-TYPE
,D-IRESTRICTP ,P-IRESTRICTP
,D-FRESTRICTP ,P-FRESTRICTP
,D-CREATE-RESTRICTION ,P-CREATE-RESTRICTION
,D-VAR-TYPE ,P-VAR-TYPE ,D-CREATE-NULL-STATE ,P-CREATE-NULL-STATE
,D-LISTIFY ,P-LISTIFY ,D-LISTIFY-REST ,P-LISTIFY-REST
,D-RESTRICTP ,P-RESTRICTP
,D-SPECIAL-FORM ,P-SPECIAL-FORM
,D-REST-EMPTY ,P-REST-EMPTY
#+NON-DETERMINISM ,D-CHOOSEP
#+NON-DETERMINISM ,P-CHOOSEP
#+NON-DETERMINISM ,D-CHOOSE-VAR
#+NON-DETERMINISM ,P-CHOOSE-VAR
#+NON-DETERMINISM ,D-EMPTY-CHOICE
#+NON-DETERMINISM ,P-EMPTY-CHOICE
#+NON-DETERMINISM ,D-NEXT-CHOICE
#+NON-DETERMINISM ,P-NEXT-CHOICE
#+NON-DETERMINISM ,D-CHOOSE-FIRST
#+NON-DETERMINISM ,P-CHOOSE-FIRST
#+NON-DETERMINISM ,D-CHOOSE-NEXT
#+NON-DETERMINISM ,P-CHOOSE-NEXT
#+TYPED ,D-COMMENSURABLE
#+TYPED ,P-COMMENSURABLE
,UMATCH
,UMATCH-R)))
(EVAL-WHEN (COMPILE EVAL)
(SETQ BACKQUOTE-EXPAND-WHEN 'READ))
;;; ?-RESTRICTIONS
(DEFMACRO CLAUSE-?-RESTRICTIONS #.%VAR-LIST%
`(COND
((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '?)
;;; normal case of ($r ? ...)
(COND ((,%%P-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R
,D
(,P-CHANGE-CURRENT ,P
(LIST '-SPECIAL-FORM- (,P-CURRENT ,P)))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
;;; case of ($r ?foo ...)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T
(COND (
(*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D ,P ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(,D-CURRENT ,D) ,ALIST)
NOBIND))
(T (,UMATCH (,P-ADVANCE ,P)
(,D-ADVANCE ,D)
,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
(,D-CURRENT ,D)
,ALIST)
NOBIND)))
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT,P))
(,D-CHECK (,D-CURRENT
,D))))
(*THROW '%/#DECISION-POINT T )))))))))
;;; *-RESTRICTIONS
(DEFMACRO CLAUSE-*-RESTRICTIONS #.%VAR-LIST%
`(COND ((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '*)
(COND ((,P-EMPTY ,P)
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (,D-LISTIFY ,D))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM-
(,P-CURRENT ,P))))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (LET (L)
(COND (%/#CONTINUE
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(OD ,D)
(OP ,P)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q L)
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP
(,D-CURRENT OD)))
(,UMATCH-R
OD OP ,CD ,CP ,ALIST NOBIND))
(T
(,UMATCH (,P-ADVANCE ,P)
,D ,CP ,CD
,ALIST NOBIND)))
)
(AND %/#RETAIN
(SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
)))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '*)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)))
(COND (%T% (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (CDR %T%))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(SETQ ,P
(,P-ADD-ITEMS ,P
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT NIL ))))
((,P-REST-EMPTY ,P)
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (,D-LISTIFY ,D))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
(
(*CATCH
'%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D ,P
,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
(CONS
(CONS
'-SPECIAL-FORM-
(,D-CURRENT ,D))
(,D-LISTIFY-REST ,D)) ,ALIST)
NOBIND))
(T
(,UMATCH
(CAR ,CP)
(CAR ,CD)
(CDR ,CP)
(CDR ,CD)
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
,D ,ALIST)
NOBIND))))
(OR NOBIND (SET (,P-RESTRICT-VAR
(,P-CURRENT ,P))
(,D-CHECK (,D-LISTIFY-REST ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P) )
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(OP ,P)
(OD ,D)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND((FUNCALL Q L)
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT OD)))
(,UMATCH OD OP ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P) )
(CONS
(CONS
'-SPECIAL-FORM-
(,D-CURRENT OD))
(CDR L)) ,ALIST)
NOBIND))
(T (,UMATCH
(,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
L ,ALIST)
NOBIND)) )
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT ,P))
(,D-CHECK L)))
(*THROW '%/#DECISION-POINT T )))))))))))))
;;; *-IRESTRICTIONS
(DEFMACRO CLAUSE-*-IRESTRICTIONS #.%VAR-LIST%
`(COND ((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '*)
(COND ((,P-REST-EMPTY ,P)
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (Q)
(COND
((OR (,D-RESTRICTP ,D)
(,D-ALL-TRUE Q (,D-LISTIFY ,D)))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM- (,P-CURRENT ,P))))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (LET (L)
(COND (%/#CONTINUE
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(F (,D-CURRENT ,D)(,D-CURRENT ,D))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (NULL L)
(,D-RESTRICTP F)
(,%%D-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,UMATCH-R ,D (,P-ADVANCE ,P)
,CD ,CP ,ALIST NOBIND))
(T (,UMATCH (,P-ADVANCE ,P) ,D
,CP ,CD
,ALIST NOBIND)))
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
)))
((EQ (,P-VAR-TYPE (,P-RESTRICT-FUNS (,P-CURRENT ,P))) '*)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)) )
(COND
(%T%
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (,P-RESTRICTP %T%)
(,P-ALL-TRUE Q %T%))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CREATE-STATE-FROM-CURRENT ,P)
(,D-CREATE-STATE-FROM-CURRENT ,D) () () ,ALIST NOBIND)
)
(SETQ ,P
(,P-CHANGE-CURRENT-ITEMS (,P-ADVANCE ,P)
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT ()
))))
(T (*THROW '%/#DECISION-POINT NIL )))))))
((,P-REST-EMPTY ,P)
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (,D-RESTRICTP ,D)
(,D-ALL-TRUE
Q
(,D-LISTIFY ,D)))
T))))(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((OR (NOT (,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(*CATCH '%/#DECISION-POINT
(,UMATCH-R (,D-CREATE-STATE-FROM-CURRENT ,D)
(,P-CREATE-STATE-FROM-CURRENT ,P)
() ()
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(CONS (CONS '-SPECIAL-FORM- (,D-CURRENT ,D))
(,D-ADVANCE ,D)) ,ALIST)
NOBIND)
))
(COND ((*CATCH '%/#DECISION-POINT
(,UMATCH (CAR ,CP) (CAR ,CD) (CDR ,CP)
(CDR ,CD)
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
,D ,ALIST) NOBIND)
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT ,P)) (,D-CHECK ,D)))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(F (,D-CURRENT ,D)(,D-CURRENT ,D))
(OD ,D)
(OP ,P)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (NULL L)
(,D-RESTRICTP F)
(,%%D-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(,%%D-SPECIAL-FORMP (CAR OD)))
(,UMATCH-R OD OP ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(CONS (CONS
'-SPECIAL-FORM-
(CAR OD)) (CDR L))
,ALIST) NOBIND))
(T
(,UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
L ,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT ,P)) (,D-CHECK L)))
(*THROW '%/#DECISION-POINT T ))))))))))))
;;; ?-VARIABLE
(DEFMACRO CLAUSE-?-VARIABLE #.%VAR-LIST%
`(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T
(COND
((*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D ,P ,CD ,CP
(ADD-ALIST
(,P-CURRENT ,P)(,D-CURRENT ,D) ,ALIST) NOBIND))
(T
(,UMATCH (,P-ADVANCE ,P)(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,P-CURRENT ,P)
(,D-CURRENT ,D) ,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-CURRENT ,P) (,D-CHECK
(,D-CURRENT ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))))
;;; *-CLAUSE
(DEFMACRO CLAUSE-* #.%VAR-LIST%
`(COND ((,P-REST-EMPTY ,P)
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R
,D
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM- (,P-CURRENT ,P))))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))(GO ,TAG))))
(T (LET (L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,UMATCH-R ,D (,P-ADVANCE ,P) ,CP ,CD ,ALIST NOBIND))
(T (,UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD ,ALIST NOBIND) ))
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))))
;;; *-VARIABLE
(DEFMACRO CLAUSE-*-VARIABLE #.%VAR-LIST%
`(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
((,P-REST-EMPTY ,P)
(COND
((*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D (,P-CHANGE-CURRENT ,P (CONS '-SPECIAL-FORM-
(,P-CURRENT ,P)))
,CD ,CP
(ADD-ALIST (,P-CURRENT ,P) ,D ,ALIST)
NOBIND))
(T (,UMATCH (CAR ,CP) (CAR ,CD) (CDR ,CP)
(CDR ,CD)
(ADD-ALIST (,P-CURRENT ,P) ,D
,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-CURRENT ,P) (,D-CHECK (,D-LISTIFY ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L (,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,UMATCH-R ,D (,P-ADVANCE ,P)
,CD ,CP (ADD-ALIST (,P-CURRENT ,P) L
,ALIST) NOBIND))
(T (,UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST (,P-CURRENT ,P) L
,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-CURRENT ,P) (,D-CHECK L)))
(*THROW '%/#DECISION-POINT T )))))))))
;;; =?-VARIABLE
(DEFMACRO CLAUSE-=?-VARIABLE #.%VAR-LIST%
`(LET ((%T% (CDR (EXPLODE (,P-CURRENT ,P)))))
(COND ((EQ (CAR %T%) '?)
(LET ((VAR (IMPLODE %T%)))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL (SETQ ,P
(,P-CHANGE-CURRENT ,P
(CDR VAL))))
(T
(SETQ ,P (,P-CHANGE-CURRENT ,P
(SYMEVAL VAR)))))
(GO ,TAG))))
(T
(LET ((VAR (IMPLODE %T%)))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL (SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P (CDR VAL))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P
(SYMEVAL VAR)))))
(GO ,TAG)))))))
;;; Choose Clause
#+NON-DETERMINISM
(DEFMACRO CHOOSE-CLAUSE #.%VAR-LIST%
`(LET ((PAT (,P-CHOOSE-VAR (,P-CURRENT ,P))))
(DO ((DAT (,D-CHOOSE-FIRST PAT ,D)
(,D-CHOOSE-NEXT DAT)))
((,D-EMPTY-CHOICE DAT) (*THROW '%/#DECISION-POINT ()))
(COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CHANGE-CURRENT ,P PAT)
(,D-NEXT-CHOICE DAT) ,CP ,CD ,ALIST NOBIND))
(*THROW '%/#DECISION-POINT T))))))
;;; Body
(DEFMACRO BODY #.%VAR-LIST%
`(OR
(COND
;;; no more pattern
((AND (NULL ,P)
(NULL ,D)
(NULL ,CP)
(NULL ,CD))
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
((AND (,P-EMPTY ,P) (NULL ,CP))
;;; so there had better be no more data, unless there are some * vars etc
(COND ((AND (,D-EMPTY ,D)(NULL ,CD))
;;; if this is a reUMATCH, we back up for next try
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
;;; more data loses in some cases
(T (COND ((OR (,D-ATOMIC ,D)
(,D-RESTRICTP ,D)
(,D-CHOOSEP ,D))
;;; if D=?<var> or = nil
(SETQ ,D (,D-CHANGE ,D (NCONS ,D))
,P (,P-CHANGE ,P (NCONS NIL)))
(GO ,TAG))
((EQ (,D-CURRENT ,D) '*)
;;; D=(* ...) could work if (CDR D) is all *-variables
(SETQ ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; we succeed if (CAR D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,D-CURRENT ,D) ,ALIST)))
(COND (%T% (SETQ ,D (,D-CHANGE-CURRENT-ITEMS
,D (,D-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CREATE-NULL-STATE)
(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,D-CURRENT ,D)
NIL
,ALIST) NOBIND) )
(OR NOBIND (SET (,D-CURRENT ,D) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))) )
(T (*THROW '%/#DECISION-POINT NIL ))))))
((,P-EMPTY ,P)
;;; if P is null, but D isn't, something is wrong sometimes
(COND ((NOT (,D-EMPTY ,D))
(COND ((OR (,D-ATOMIC ,D)
(,D-RESTRICTP ,D)
(,D-CHOOSEP ,D))
;;; if D=?<var> or = nil
(SETQ ,D (,D-CHANGE ,D (NCONS ,D))
,P (,P-CHANGE ,P (NCONS NIL)))
(GO ,TAG))
((EQ (,D-CURRENT ,D) '*)
;;; D=(* ...) could work if (CDR D) is all *-variables
(SETQ ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; we succeed if (CAR D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,D-CURRENT ,D) ,ALIST)))
(COND (%T%
(SETQ ,D (,D-CHANGE-CURRENT-ITEMS ,D
(,D-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CREATE-NULL-STATE)
(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,D-CURRENT ,D) NIL
,ALIST) NOBIND) )
(OR NOBIND (SET (,D-CURRENT ,D) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))) ))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (SETQ ,P (CAR ,CP) ,D (CAR ,CD) ,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
((AND (,D-EMPTY ,D)
(NOT (,P-RESTRICTP (,P-CURRENT ,P))))
;;; if D is null and P isn't, we can still win
(COND ((OR (,P-ATOMIC ,P)
(,P-RESTRICTP ,P)
(,P-CHOOSEP ,P))
;;; if P=?<var> or = nil
(SETQ ,P (,P-CHANGE ,P (NCONS ,P))
,D (,D-CHANGE ,D (NCONS NIL)))
(GO ,TAG))
((EQ (,P-CURRENT ,P) '*)
;;; P=(* ...) could work if (CDR P) is all *-variables
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '*)
;;; we succeed if (CAR P) = (*<var> ...) and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T%
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,UMATCH (,P-ADVANCE ,P)
(,D-CREATE-NULL-STATE)
,CP ,CD
(ADD-ALIST
(,P-CURRENT ,P) NIL
,ALIST) NOBIND) )
(OR NOBIND (SET (,P-CURRENT ,P) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))) )
))
#+TYPED
((NOT (,P-COMMENSURABLE ,P ,D))
(*THROW '%/#DECISION-POINT ()))
((OR (,P-ATOMIC ,P) (,D-ATOMIC ,D))
;;; here we listify things if necessary
(SETQ ,P (,P-CHANGE ,P (NCONS ,P))
,D (,D-CHANGE ,D (NCONS ,D)))
(GO ,TAG))
;;; ? restrictions
((AND (,P-RESTRICTP (,P-CURRENT ,P))
(EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
(NOT (,D-EMPTY ,D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (PRED) (COND ((OR (,D-RESTRICTP (,D-CURRENT ,D))
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(FUNCALL PRED (,D-CURRENT ,D)))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P)))))
(COND ((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
(CLAUSE-?-RESTRICTIONS . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '=)
(LET ((VAR
(IMPLODE
(CDR (EXPLODE (,P-RESTRICT-VAR (,P-CURRENT ,P)))))))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))
,ALIST
(ADD-ALIST VAR (SYMEVAL VAR)
,ALIST))))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT () ))))
((,P-FRESTRICTP (,P-CURRENT ,P))
(CLAUSE-*-RESTRICTIONS . ,#.%ARG-LIST%))
((,P-IRESTRICTP (,P-CURRENT ,P))
(CLAUSE-*-IRESTRICTIONS . ,#.%ARG-LIST%))
((EQ (,P-CURRENT ,P) '*)
;;; (* ...)
(CLAUSE-* . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '=)
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE . ,#.%ARG-LIST%))
((AND (,D-RESTRICTP (,D-CURRENT ,D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (PRED) (COND ((OR (,P-RESTRICTP
(,P-CURRENT ,P))
(,%%P-SPECIAL-FORMP (,P-CURRENT ,P))
(FUNCALL PRED (,P-CURRENT ,P)))
T))))
(,D-RESTRICT-FUNS (,D-CURRENT ,D)))))
(COND ((EQ (,D-VAR-TYPE (,D-RESTRICT-VAR (,D-CURRENT ,D))) '?)
(COND ((,P-EMPTY ,P)(*THROW '%/#DECISION-POINT ()))
(T (CLAUSE-?-RESTRICTIONS . ,#.%ARG-LIST-R%))))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '=)
(LET ((VAR
(IMPLODE
(CDR (EXPLODE (,P-RESTRICT-VAR (,P-CURRENT ,P)))))))
(LET ((VAL
(ASSQ VAR ,ALIST)))
(COND (VAL
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))
,ALIST
(ADD-ALIST VAR (SYMEVAL VAR)
,ALIST))))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT () ))))
((,D-FRESTRICTP (,D-CURRENT ,D))
(CLAUSE-*-RESTRICTIONS . ,#.%ARG-LIST%))
((,D-IRESTRICTP (,D-CURRENT ,D))
(CLAUSE-*-IRESTRICTIONS .,#.%ARG-LIST-R%))
((EQ (,D-CURRENT ,D) '*)
;;; (* ...)
(CLAUSE-* . ,#.%ARG-LIST-R%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE . ,#.%ARG-LIST-R%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '=)
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE . ,#.%ARG-LIST-R%))
((OR (EQUAL (,P-CURRENT ,P) (,D-CURRENT ,D)) (EQ (,P-CURRENT ,P) '?) (EQ (,D-CURRENT ,D) '?))
;;; easiest case
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE . ,#.%ARG-LIST%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE . ,#.%ARG-LIST-R%))
#+NON-DETERMINISM
((,P-CHOOSEP (,P-CURRENT ,P))
(CHOOSE-CLAUSE . ,#.%ARG-LIST%))
#+NON-DETERMINISM
((,D-CHOOSEP (,D-CURRENT ,D))
(CHOOSE-CLAUSE . ,#.%ARG-LIST-R%))
#+TYPED
((NOT (,P-COMMENSURABLE (,P-CURRENT ,P)
(,D-CURRENT ,D)))
(*THROW '%/#DECISION-POINT ()))
((AND (NOT (,P-CURRENT-ATOMIC ,P))
(OR (,D-CURRENT-EMPTY ,D)
(NOT (,D-CURRENT-ATOMIC ,D))))
;;; the big recursion
;;; notice that we want nil to be a list here, not an atom
;;; since ((*) ...) (nil ...) needs a chance
(SETQ
,CP (CONS (,P-ADVANCE ,P) ,CP)
,CD (CONS (,D-ADVANCE ,D) ,CD)
,P (,P-CREATE-STATE-FROM-CURRENT ,P) ,D (,D-CREATE-STATE-FROM-CURRENT ,D))
(GO ,TAG)))
(*THROW '%/#DECISION-POINT () )))
;;*page
;;; The Unification Matcher
;;; Matches 2 patterns.
(DECLARE (SPECIAL #.(%%%MAKE-NAME%%% 'STATISTICS)
#.(%%%MAKE-NAME%%% 'CALLS))
(FIXNUM #.(%%%MAKE-NAME%%% 'CALLS)))
(SETQ #.(%%%MAKE-NAME%%% 'STATISTICS) () #.(%%%MAKE-NAME%%% 'CALLS) 0)
(DEFUN #.(%%%MAKE-NAME%%% 'CALLS) () #.(%%%MAKE-NAME%%% 'CALLS))
(DEFUN #.(%%%MAKE-NAME%%% 'STATISTICS) (X)
(AND X (SETQ #.(%%%MAKE-NAME%%% 'CALLS) 0))
(SETQ #.(%%%MAKE-NAME%%% 'STATISTICS) X))
;;; (%UMATCH <pat> <data> <initial alist, optional>)
(DEFUN #.MATCH-NAME %/#n
(AND #.(%%%MAKE-NAME%%% 'STATISTICS)
(SETQ #.(%%%MAKE-NAME%%% 'CALLS)
(1+ #.(%%%MAKE-NAME%%% 'CALLS))))
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) ()) )) NIL))
;;; (CONTINUE-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-CONTINUE) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4)))) ()) ))
T))
;;; (UMATCH-NOBIND <pat> <data> <initial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-NOBIND) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) T) )) NIL))
;;; (CONTINUE-NOBIND-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-CONTINUE-NOBIND) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4)))) T) ))
T))
;;; Asymmetric Matcher
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH) (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-NEXT
#+NON-DETERMINISM D-CHOOSE-NEXT
#+TYPED P-COMMENSURABLE
#+TYPED D-COMMENSURABLE
#.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R)) ))
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH-R) (%/#D %/#P %/#CD %/#CP %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#D %/#P %/#CD %/#CP %/#ALIST UMATCH D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-NEXT
#+NON-DETERMINISM P-CHOOSE-NEXT
#+TYPED D-COMMENSURABLE
#+TYPED P-COMMENSURABLE
#.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R))))
;;; Symmetric Matcher
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
#+SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH) (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH P-ADVANCE P-ADVANCE
P-CURRENT P-CURRENT P-RESTRICT-VAR P-RESTRICT-VAR
P-CURRENT-ATOMIC P-CURRENT-ATOMIC
P-CURRENT-EMPTY P-CURRENT-EMPTY
P-EMPTY P-EMPTY P-CHANGE-CURRENT P-CHANGE-CURRENT
P-CHANGE P-CHANGE P-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
P-ADD-ITEM P-ADD-ITEM P-ADD-ITEMS P-ADD-ITEMS
P-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
P-CHECK
P-CHECK
P-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE P-ALL-TRUE
P-ATOMIC P-ATOMIC
P-RESTRICT-TYPE P-RESTRICT-TYPE
P-IRESTRICTP P-IRESTRICTP
P-FRESTRICTP P-FRESTRICTP
P-CREATE-RESTRICTION P-CREATE-RESTRICTION
P-VAR-TYPE P-VAR-TYPE P-CREATE-NULL-STATE P-CREATE-NULL-STATE
P-LISTIFY P-LISTIFY P-LISTIFY-REST P-LISTIFY-REST
P-RESTRICTP P-RESTRICTP
P-SPECIAL-FORM P-SPECIAL-FORM
P-REST-EMPTY P-REST-EMPTY
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-NEXT
#+NON-DETERMINISM P-CHOOSE-NEXT
#+TYPED P-COMMENSURABLE
#+TYPED P-COMMENSURABLE
#.(%%%MAKE-NAME%%% 'UMATCH) #.(%%%MAKE-NAME%%% 'UMATCH))))